home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / FSYS.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  28.0 KB  |  1,275 lines
  1. /*
  2.  * File: fsys.r
  3.  *  Contents: close, exit, getenv, open, read, reads, remove, rename, [save],
  4.  *   seek, stop, [system], where, write, writes, [getch, getche, kbhit]
  5.  */
  6.  
  7. #if MICROSOFT || SCO_XENIX
  8. #define BadCode
  9. #endif                    /* MICROSOFT || SCO_XENIX */
  10.  
  11. #ifdef XENIX_386
  12. #define register
  13. #endif                    /* XENIX_386 */
  14. /*
  15.  * The following code is operating-system dependent [@fsys.01]. Include
  16.  *  system-dependent files and declarations.
  17.  */
  18.  
  19. #if PORT
  20.    /* nothing to do */
  21. Deliberate Syntax Error
  22. #endif                    /* PORT */
  23.  
  24. #if AMIGA || ATARI_ST || MSDOS || MVS || OS2 || UNIX || VM || VMS
  25.    /* nothing to do */
  26. #endif                    /* AMIGA || ATARI_ST || ... */
  27.  
  28. #if MACINTOSH
  29. #if MPW
  30. #define isatty(fd) (!ioctl((fd), FIOINTERACTIVE))
  31. #define fflush(f) 0
  32. #endif                    /* MPW */
  33. #endif                    /* MACINTOSH */
  34.  
  35. /*
  36.  * End of operating-system specific code.
  37.  */
  38.  
  39.  
  40. "close(f) - close file f."
  41.  
  42. function{1} close(f)
  43.  
  44.    if !is:file(f) then
  45.       runerr(105, f)
  46.  
  47.    abstract {
  48.       return file ++ integer
  49.       }
  50.  
  51.    body {
  52.       FILE *fp;
  53.  
  54.       fp = BlkLoc(f)->file.fd;
  55.  
  56.       /*
  57.        * Close f, using fclose, pclose, or wclose as appropriate.
  58.        */
  59.  
  60.    
  61. #if ARM || OS2 || UNIX || VMS
  62.       /*
  63.        * Close pipe if pipes are supported.
  64.        */
  65.  
  66.       if (BlkLoc(f)->file.status & Fs_Pipe) {
  67.          BlkLoc(f)->file.status = 0;
  68.          return C_integer((pclose(fp) >> 8) & 0377);
  69.          }
  70.       else
  71. #endif                    /* ARM || OS2 || UNIX || VMS */
  72.  
  73.       fclose(fp);
  74.       BlkLoc(f)->file.status = 0;
  75.  
  76.       /*
  77.        * Return the closed file.
  78.        */
  79.       return f;
  80.       }
  81. end
  82.  
  83.  
  84. "exit(i) - exit process with status i, which defaults to 0."
  85.  
  86. function{} exit(status)
  87.    if !def:C_integer(status, NormalExit) then
  88.       runerr(0)
  89.    inline {
  90.       c_exit((int)status);
  91.       }
  92. end
  93.  
  94.  
  95. "getenv(s) - return contents of environment variable s."
  96.  
  97. #ifndef EnvVars
  98. function{0} getenv(s)
  99.    abstract {
  100.       return empty_type
  101.       }
  102.    inline {
  103.       fail;
  104.       }
  105. #else                    /* EnvVars */
  106. function{0,1} getenv(s)
  107.  
  108.    /*
  109.     * Make a C-style string out of s
  110.     */
  111.    if !cnv:C_string(s) then
  112.       runerr(103,s)
  113.    abstract {
  114.       return string
  115.       }
  116.  
  117.    inline {
  118.       register char *p;
  119.       long l;
  120.  
  121.       if ((p = getenv(s)) != NULL) {    /* get environment variable */
  122.          l = strlen(p);
  123.      Protect(p = alcstr(p,l),runerr(0));
  124.          return string(l,p);
  125.          }
  126.       else                 /* fail if not in environment */
  127.          fail;
  128.  
  129.       }
  130. #endif                    /* EnvVars */
  131. end
  132.  
  133.  
  134. #ifdef OpenAttributes
  135. "open(fname, spec, attrstring) - open file fname with specification spec."
  136. function{0,1} open(fname, spec, attrstring)
  137. #else                        /* OpenAttributes */
  138. "open(fname, spec) - open file fname with specification spec."
  139. function{0,1} open(fname, spec)
  140. #endif                        /* OpenAttributes */
  141.    declare {
  142.       tended struct descrip filename;
  143.       }
  144.  
  145.    /*
  146.     * fopen and popen require a C string.
  147.     */
  148.    if !cnv:C_string(fname) then
  149.       runerr(103, fname)
  150.  
  151.    /*
  152.     * spec defaults to "r".
  153.     */
  154.    if !def:tmp_string(spec, letr) then
  155.       runerr(103, spec)
  156.  
  157. #ifdef OpenAttributes
  158.    /*
  159.     * Convert attrstr to a string, defaulting to "".
  160.     */
  161.    if !def:C_string(attrstring, emptystr);
  162. #endif                                  /* OpenAttributes */
  163.  
  164.    abstract {
  165.       return file
  166.       }
  167.  
  168.    body {
  169.       register word slen;
  170.       register int i;
  171.       register char *s;
  172.       int status;
  173.       char mode[4];
  174.       extern FILE *fopen();
  175.       FILE *f;
  176.       struct b_file *fl;
  177.    
  178.  
  179. /*
  180.  * The following code is operating-system dependent [@fsys.02].  Make
  181.  *  declarations as needed for opening files.
  182.  */
  183.  
  184. #if PORT
  185. Deliberate Syntax Error
  186. #endif                    /* PORT */
  187.  
  188. #if AMIGA || MACINTOSH
  189.    /* nothing is needed */
  190. #endif                    /* AMIGA || MACINTOSH */
  191.  
  192. #if ARM
  193.       extern FILE *popen(const char *, const char *);
  194.       extern int pclose(FILE *);
  195. #endif                                  /* ARM */
  196.  
  197. #if ATARI_ST || MSDOS || OS2 || MVS || VM
  198.       char untranslated;
  199. #endif                    /* ATARI_ST || MS-DOS || ... */
  200.  
  201. #if MACINTOSH
  202. #if LSC
  203.       char untranslated;
  204. #endif                    /* LSC */
  205. #endif                    /* MACINTOSH */
  206.  
  207. #if OS2 || UNIX || VMS
  208.       extern FILE *popen();
  209. #endif                    /* OS2 || UNIX || VMS */
  210.  
  211. /*
  212.  * End of operating-system specific code.
  213.  */
  214.  
  215.       status = 0;
  216.  
  217. /*
  218.  * The following code is operating-system dependent [@fsys.03].  Provide
  219.  *  declaration for untranslated line-termination mode, if supported.
  220.  */
  221.  
  222. #if PORT
  223.    /* nothing to do */
  224. Deliberate Syntax Error
  225. #endif                    /* PORT */
  226.  
  227. #if AMIGA
  228.    /* translated mode could be supported, but is not now */
  229. #endif                    /* AMIGA */
  230.  
  231. #if ARM || UNIX || VMS
  232.    /* nothing to do */
  233. #endif                                  /* ARM || UNIX || VMS */
  234.    
  235. #if ATARI_ST || MSDOS || MVS || OS2 || VM
  236.       untranslated = 0;
  237. #endif                    /* ATARI_ST || MSDOS || ... */
  238.  
  239. #if MACINTOSH
  240. #if LSC
  241.       untranslated = 0;
  242. #endif                    /* LSC */
  243. #endif                    /* MACINTOSH */
  244.  
  245. /*
  246.  * End of operating-system specific code.
  247.  */
  248.  
  249.       /*
  250.        * Scan spec, setting appropriate bits in status.  Produce a
  251.        *  run-time error if an unknown character is encountered.
  252.        */
  253.       s = StrLoc(spec);
  254.       slen = StrLen(spec);
  255.       for (i = 0; i < slen; i++) {
  256.          switch (*s++) {
  257.             case 'a':
  258.             case 'A':
  259.                status |= Fs_Write|Fs_Append;
  260.                continue;
  261.             case 'b':
  262.             case 'B':
  263.                status |= Fs_Read|Fs_Write;
  264.                continue;
  265.             case 'c':
  266.             case 'C':
  267.                status |= Fs_Create|Fs_Write;
  268.                continue;
  269.             case 'r':
  270.             case 'R':
  271.                status |= Fs_Read;
  272.                continue;
  273.             case 'w':
  274.             case 'W':
  275.                status |= Fs_Write;
  276.                continue;
  277.  
  278. /*
  279.  * The following code is operating-system dependent [@fsys.04].  Handle
  280.  * untranslated line-terminator mode, pipes, and/or window modes if supported.
  281.  */
  282.  
  283. #if PORT
  284.             case 't':
  285.             case 'T':
  286.             case 'u':
  287.             case 'U':
  288.                continue;            /* no-op */
  289. Deliberate Syntax Error
  290. #endif                    /* PORT */
  291.  
  292. #if AMIGA 
  293.             case 't':
  294.             case 'T':
  295.             case 'u':
  296.             case 'U':
  297.                continue;            /* no-op */
  298. #endif                    /* AMIGA */
  299.  
  300. #if ARM || UNIX || VMS
  301.             case 't':
  302.             case 'T':
  303.             case 'u':
  304.             case 'U':
  305.                continue;            /* no-op */
  306.             case 'p':
  307.             case 'P':
  308.                status |= Fs_Pipe;
  309.                continue;
  310. #endif                    /* ARM || UNIX || VMS */
  311.  
  312. #if ATARI_ST || MSDOS || OS2 || SASC
  313.             case 't':
  314.             case 'T':
  315.                untranslated = 0;
  316.  
  317. #if OS2
  318.             case 'p':
  319.             case 'P':
  320.                status |= Fs_Pipe;
  321.                continue;
  322. #endif                    /* OS2 */
  323.  
  324. #ifdef RecordIO
  325.                status &= ~Fs_Record;
  326. #endif                    /* RecordIO */
  327.  
  328.                continue;
  329.             case 'u':
  330.             case 'U':
  331.                untranslated = 1;
  332.  
  333. #ifdef RecordIO
  334.                status &= ~Fs_Record;
  335. #endif                    /* RecordIO */
  336.  
  337.                continue;
  338. #endif                    /* ATARI_ST || MSDOS || ... */
  339.    
  340. #ifdef RecordIO
  341.             case 's':
  342.             case 'S':
  343.                untranslated = 1;
  344.                status |= Fs_Record;
  345.                continue;
  346. #endif                                  /* RecordIO */
  347.    
  348. #if MACINTOSH
  349. #if LSC
  350.             case 't':
  351.             case 'T':
  352.                untranslated = 0;
  353.                continue;
  354.             case 'u':
  355.             case 'U':
  356.                untranslated = 1;
  357.                continue;
  358. #endif                    /* LSC */
  359. #endif                    /* MACINTOSH */
  360.    
  361.    /*
  362.     * End of operating-system specific code.
  363.     */
  364.    
  365.  
  366.             default:
  367.                runerr(209, spec);
  368.             }
  369.          }
  370.  
  371.       /*
  372.        * Construct a mode field for fopen/popen.
  373.        */
  374.       mode[0] = '\0';
  375.       mode[1] = '\0';
  376.       mode[2] = '\0';
  377.       mode[3] = '\0';
  378.  
  379.       if ((status & (Fs_Read|Fs_Write)) == 0)   /* default: read only */
  380.          status |= Fs_Read;
  381.       if (status & Fs_Create)
  382.          mode[0] = 'w';
  383.       else if (status & Fs_Append)
  384.          mode[0] = 'a';
  385.       else if (status & Fs_Read)
  386.          mode[0] = 'r';
  387.       else
  388.          mode[0] = 'w';
  389.  
  390. /*
  391.  * The following code is operating-system dependent [@fsys.05].  Handle open
  392.  *  modes.
  393.  */
  394.  
  395. #if PORT
  396.       if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write))
  397.          mode[1] = '+';
  398. Deliberate Syntax Error
  399. #endif                    /* PORT */
  400.  
  401. #if AMIGA || ARM || UNIX || VMS
  402.       if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write))
  403.          mode[1] = '+';
  404. #endif                                  /* AMIGA || ARM || UNIX || VMS */
  405.  
  406. #if ATARI_ST
  407.       if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) {
  408.          mode[1] = '+';
  409.          mode[2] = untranslated ? 'b' : 'a';
  410.          }
  411.       else mode[1] = untranslated ? 'b' : 'a';
  412. #endif                                  /* ATARI_ST */
  413.  
  414. #if MSDOS || OS2
  415.       if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) {
  416.          mode[1] = '+';
  417.          mode[2] = untranslated ? 'b' : 't';
  418.          }
  419.       else mode[1] = untranslated ? 'b' : 't';
  420. #endif                                  /* MSDOS || OS2 */
  421.  
  422. #if MACINTOSH
  423. #if LSC
  424.       untranslated = 0;
  425. #endif                    /* LSC */
  426. #endif                    /* MACINTOSH */
  427.  
  428. #if MVS || VM
  429.       if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) {
  430.          mode[1] = '+';
  431.          mode[2] = untranslated ? 'b' : 0;
  432.          }
  433.       else mode[1] = untranslated ? 'b' : 0;
  434. #endif                                  /* MVS || VM */
  435.  
  436. /*
  437.  * End of operating-system specific code.
  438.  */
  439.  
  440.       /*
  441.        * Open the file with fopen or popen.
  442.        */
  443.  
  444. #ifdef OpenAttributes
  445. #if SASC
  446. #ifdef RecordIO
  447.          f = afopen(fname, mode, status & Fs_Record ? "seq" : "",
  448.                     attrstring);
  449. #else                    /* RecordIO */
  450.          f = afopen(fname, mode, "", attrstring);
  451. #endif                                  /* RecordIO */
  452. #endif                                  /* SASC */
  453.  
  454. #else                                   /* OpenAttributes */
  455.  
  456.  
  457. #if ARM || OS2 || UNIX || VMS
  458.       if (status & Fs_Pipe) {
  459.          if (status != (Fs_Read|Fs_Pipe) && status != (Fs_Write|Fs_Pipe))
  460.             runerr(209, spec);
  461.          f = popen(fname, mode);
  462.          }
  463.       else
  464. #endif                                  /* ARM || OS2 || UNIX || VMS */
  465.  
  466.          f = fopen(fname, mode);
  467. #endif                                  /* OpenAttributes */
  468.  
  469.       /*
  470.        * Fail if the file cannot be opened.
  471.        */
  472.       if (f == NULL)
  473.          fail;
  474.  
  475. #if MACINTOSH
  476. #if MPW
  477. /* Set file type and creator. */
  478.       {
  479.       FInfo info;
  480.  
  481.       if (getfinfo(fname,0,&info) == 0) {
  482.          if (status & Fs_Write && info.fdType == 0 && info.fdCreator == 0) {
  483.             info.fdType = 'TEXT';
  484.             info.fdCreator = 'MPS ';
  485.             setfinfo(fname,0,&info);
  486.             }
  487.          }
  488.       }
  489. #endif                    /* MPW */
  490. #endif                    /* MACINTOSH */
  491.  
  492.       /*
  493.        * Return the resulting file value.
  494.        */
  495.       StrLen(filename) = strlen(fname);
  496.       StrLoc(filename) = fname;
  497.  
  498.       Protect(fl = alcfile(f, status, &filename), runerr(0));
  499.       return file(fl);
  500.       }
  501. end
  502.  
  503.  
  504. "read(f) - read line on file f."
  505.  
  506. function{0,1} read(f)
  507.    /*
  508.     * Default f to &input.
  509.     */
  510.    if is:null(f) then
  511.       inline {
  512.          f = input;
  513.          }
  514.    else if !is:file(f) then
  515.       runerr(105, f)
  516.  
  517.    abstract {
  518.       return string
  519.       }
  520.  
  521.    body {
  522.       register word slen, rlen;
  523.       register char *sp;
  524.       int status;
  525.       static char sbuf[MaxReadStr];
  526.       FILE *fp;
  527.  
  528.       /*
  529.        * Get a pointer to the file and be sure that it is open for reading.
  530.        */
  531.       fp = BlkLoc(f)->file.fd;
  532.       status = BlkLoc(f)->file.status;
  533.       if ((status & Fs_Read) == 0) 
  534.          runerr(212, f);
  535.  
  536. #ifdef StandardLib
  537.       if (status & Fs_Writing) {
  538.          fseek(fp, 0L, SEEK_CUR);
  539.          BlkLoc(f)->file.status &= ~Fs_Writing;
  540.          }
  541.       BlkLoc(f)->file.status |= Fs_Reading;
  542. #endif                    /* StandardLib */
  543.  
  544.       /*
  545.        * Use getstrg to read a line from the file, failing if getstrg
  546.        *  encounters end of file. [[ What about -2?]]
  547.        */
  548.       StrLen(result) = 0;
  549.       do {
  550.  
  551. #ifdef RecordIO
  552.          if ((slen = (status & Fs_Record ? getrec(sbuf, MaxReadStr, fp) :
  553.                                            getstrg(sbuf, MaxReadStr, fp)))
  554.              == -1) fail;
  555. #else                    /* RecordIO */
  556.          if ((slen = getstrg(sbuf,MaxReadStr,fp)) == -1)
  557.             fail;
  558. #endif                                  /* RecordIO */
  559.  
  560.          /*
  561.           * Allocate the string read and make result a descriptor for it.
  562.           */
  563.          rlen = slen < 0 ? (word)MaxReadStr : slen;
  564.          Protect(sp = alcstr(sbuf,rlen), runerr(0));
  565.          if (StrLen(result) == 0)
  566.             StrLoc(result) = sp;
  567.          StrLen(result) += rlen;
  568.          } while (slen < 0);
  569.       return result;
  570.       }
  571. end
  572.  
  573.  
  574. "reads(f,i) - read i characters on file f."
  575.  
  576. function{0,1} reads(f,i)
  577.    /*
  578.     * Default f to &input.
  579.     */
  580.    if is:null(f) then
  581.       inline {
  582.          f = input;
  583.          }
  584.    else if !is:file(f) then
  585.       runerr(105, f)
  586.  
  587.    /*
  588.     * i defaults to 1 (read a single character)
  589.     */
  590.    if !def:C_integer(i,1L) then
  591.       runerr(101, i)
  592.  
  593.    abstract {
  594.       return string
  595.       }
  596.  
  597.    body {
  598.       long tally;
  599.       char *s;
  600.       int status;
  601.       FILE *fp;
  602.  
  603.       /*
  604.        * Get a pointer to the file and be sure that it is open for reading.
  605.        */
  606.       fp = BlkLoc(f)->file.fd;
  607.       status = BlkLoc(f)->file.status;
  608.       if ((status & Fs_Read) == 0) 
  609.          runerr(212, f);
  610.  
  611. #ifdef StandardLib
  612.       if (status & Fs_Writing) {
  613.          fseek(fp, 0L, SEEK_CUR);
  614.          BlkLoc(f)->file.status &= ~Fs_Writing;
  615.          }
  616.       BlkLoc(f)->file.status |= Fs_Reading;
  617. #endif                    /* StandardLib */
  618.  
  619.       /*
  620.        * Be sure that a positive number of bytes is to be read.
  621.        */
  622.       if (i <= 0) {
  623.          irunerr(205, i);
  624.  
  625.          errorfail;
  626.          }
  627.  
  628.       /*
  629.        * For now, assume we can read the full number of bytes.
  630.        */
  631.       Protect(StrLoc(result) =  alcstr(NULL, i), runerr(0));
  632.       StrLen(result) = 0;
  633.  
  634. #if AMIGA
  635.       /*
  636.        * The following code is special for Lattice 4.0 -- it was different
  637.        *  for Lattice 3.10.  It probably won't work correctly with other
  638.        *  C compilers.
  639.        */
  640.       if (IsInteractive(_ufbs[fileno(fp)].ufbfh)) {
  641.          if ((i = read(fileno(fp),StrLoc(result),i)) <= 0)
  642.             fail;
  643.          StrLen(result) = i;
  644.          /*
  645.           * We may not have used the entire amount of storage we reserved.
  646.           */
  647.          MMStr(DiffPtrs(StrLoc(result) + i, strfree));
  648.      strtotal += DiffPtrs(StrLoc(result) + i, strfree);
  649.          strfree = StrLoc(result) + i;
  650.          return result;
  651.          }
  652. #endif                    /* AMIGA */
  653.  
  654.       tally = longread(StrLoc(result),sizeof(char),i,fp);
  655.  
  656.       if (tally == 0)
  657.          fail;
  658.       StrLen(result) = tally;
  659.       /*
  660.        * We may not have used the entire amount of storage we reserved.
  661.        */
  662.       MMStr(DiffPtrs(StrLoc(result) + tally, strfree));
  663.       strtotal += DiffPtrs(StrLoc(result) + tally, strfree);
  664.       strfree = StrLoc(result) + tally;
  665.       return result;
  666.       }
  667. end
  668.  
  669.  
  670. "remove(s) - remove the file named s."
  671.  
  672. function{0,1} remove(s)
  673.  
  674.    /*
  675.     * Make a C-style string out of s
  676.     */
  677.    if !cnv:C_string(s) then
  678.       runerr(103,s)
  679.    abstract {
  680.       return null
  681.       }
  682.  
  683.    inline {
  684.       if (unlink(s) != 0)
  685.          fail;
  686.       return nulldesc;
  687.       }
  688. end
  689.  
  690.  
  691. "rename(s1,s2) - rename the file named s1 to have the name s2."
  692.  
  693. function{0,1} rename(s1,s2)
  694.  
  695.    /*
  696.     * Make C-style strings out of s1 and s2
  697.     */
  698.    if !cnv:C_string(s1) then
  699.       runerr(103,s1)
  700.    if !cnv:C_string(s2) then
  701.       runerr(103,s2)
  702.  
  703.    abstract {
  704.       return null
  705.       }
  706.  
  707.    body {
  708. /*
  709.  * The following code is operating-system dependent [@fsys.06].  Rename the
  710.  *  file, and fail if unsuccessful.
  711.  */
  712.  
  713. #if PORT
  714.    /* need something */
  715. Deliberate Syntax Error
  716. #endif                    /* PORT */
  717.  
  718. #if AMIGA || ARM || ATARI_ST || MACINTOSH || MSDOS || MVS || OS2 || VM || VMS
  719.       {
  720.       if (rename(s1,s2) != 0)
  721.          fail;
  722.       }
  723. #endif                    /* AMIGA || ARM || ATARI_ST ... */
  724.  
  725. #if UNIX
  726.       if (link(s1,s2) != 0)
  727.          fail;
  728.       if (unlink(s1) != 0) {
  729.          unlink(s2);    /* try to undo partial rename */
  730.          fail;
  731.          }
  732. #endif                    /* UNIX */
  733.  
  734. /*
  735.  * End of operating-system specific code.
  736.  */
  737.  
  738.       return nulldesc;
  739.       }
  740. end
  741.  
  742. #ifdef ExecImages
  743.  
  744. "save(s) - save the run-time system in file s"
  745.  
  746. function{0,1} save(s)
  747.  
  748.    if !cnv:C_string(s) then
  749.       runerr(103,s)
  750.  
  751.    abstract {
  752.       return integer
  753.       }
  754.  
  755.    body {
  756.       char sbuf[MaxCvtLen];
  757.       int f, fsz;
  758.  
  759.       dumped = 1;
  760.  
  761.       /*
  762.        * Open the file for the executable image.
  763.        */
  764.       f = creat(s, 0777);
  765.       if (f == -1)
  766.          fail;
  767.       fsz = wrtexec(f);
  768.       /*
  769.        * It happens that most wrtexecs don't check the system call return
  770.        *  codes and thus they'll never return -1.  Nonetheless...
  771.        */
  772.       if (fsz == -1)
  773.          fail;
  774.       /*
  775.        * Return the size of the data space.
  776.        */
  777.       return C_integer fsz;
  778.       }
  779. end
  780. #endif                    /* ExecImages */
  781.  
  782.  
  783. "seek(f,i) - seek to offset i in file f."
  784. " [[ What about seek error ? ]] "
  785.  
  786. function{0,1} seek(f,o)
  787.  
  788.    /*
  789.     * f must be a file
  790.     */
  791.    if !is:file(f) then
  792.       runerr(105,f)
  793.  
  794.    /*
  795.     * o must be an integer and defaults to 1.
  796.     */
  797.    if !def:C_integer(o,1L) then
  798.       runerr(0)
  799.  
  800.    abstract {
  801.       return file
  802.       }
  803.  
  804.    body {
  805.       FILE *fd;
  806.  
  807.       fd = BlkLoc(f)->file.fd;
  808.       if (BlkLoc(f)->file.status == 0)
  809.          fail;
  810.  
  811.  
  812.       if (o > 0) {
  813.          if (fseek(fd, o - 1, SEEK_SET) == -1)
  814.             fail;
  815.          }
  816.       else {
  817.          if (fseek(fd, o, SEEK_END) == -1)
  818.             fail;
  819.          }
  820. #ifdef StandardLib
  821.       BlkLoc(f)->file.status &= ~(Fs_Reading | Fs_Writing);
  822. #endif                    /* StandardLib */
  823.       return f;
  824.       }
  825. end
  826.  
  827.  
  828. #ifdef SystemFnc
  829.  
  830. "system(s) - execute string s as a system command."
  831.  
  832. function{1} system(s)
  833.    /*
  834.     * Make a C-style string out of s
  835.     */
  836.    if !cnv:C_string(s) then
  837.       runerr(103,s)
  838.  
  839.    abstract {
  840.       return integer
  841.       }
  842.  
  843.    inline {
  844.       /*
  845.        * Pass the C string to the system() function and return
  846.        * the exit code of the command as the result of system().
  847.        * Note, the expression on a "return" may not have side effects,
  848.        * so the exit code must be returned via a variable.
  849.        */
  850.       C_integer i;
  851.  
  852.    
  853. /*
  854.  * The following code is operating-system dependent [@fsys.12].  Perform system
  855.  *  call.  Should not get here unless system(s) is supported.
  856.  */
  857.  
  858. #if PORT
  859. Deliberate Syntax Error
  860. #endif                    /* PORT */
  861.  
  862. #if AMIGA || OS2 || UNIX
  863.       i = ((system(s) >> 8) & 0377);
  864. #endif                    /* AMIGA || OS2 || ... */
  865.  
  866. #if MSDOS
  867. #if HIGHC_386
  868.       i = (C_integer)system(s);
  869. #else                    /* HIGHC_386 */
  870.       i = ((system(s) >> 8) & 0377);
  871. #endif                    /* HIGHC_386 */
  872. #endif                    /* MSDOS */
  873.  
  874. #if ARM 
  875.       i = (C_integer)system(s);
  876. #endif                    /* ARM */
  877.  
  878. #if ATARI_ST || VMS
  879.       i = system(s);
  880. #endif                    /* ATARI_ST || VMS */
  881.  
  882. #if MACINTOSH
  883.    /* Should not get here */
  884. #endif                    /* MACINTOSH */
  885.  
  886. #if MVS || VM
  887. #if SASC && MVS
  888.    {
  889.       char *wprefix;
  890.       wprefix = malloc(strlen(s)+5);
  891.                      /* hope this will do no harm... */
  892.       sprintf(wprefix,"tso:%s",s);
  893.       i = (C_integer)system(wprefix);
  894.       free(wprefix);
  895.    }
  896. #else                    /* SASC && MVS */
  897.    i = (C_integer)system(s);
  898. #endif                    /* SASC && MVS */
  899. #endif                                  /* MVS || VM */
  900.  
  901. /*
  902.  * End of operating-system specific code.
  903.  */
  904.       return C_integer i;
  905.       }
  906. end
  907.  
  908. #endif                    /* SystemFnc */
  909.  
  910.  
  911. "where(f) - return current offset position in file f."
  912.  
  913. function{0,1} where(f)
  914.  
  915.    if !is:file(f) then
  916.       runerr(105,f)
  917.  
  918.    abstract {
  919.       return integer
  920.       }
  921.  
  922.    body {
  923.       FILE *fd;
  924.       long ftell();
  925.       long pos;
  926.  
  927.       fd = BlkLoc(f)->file.fd;
  928.  
  929.       if ((BlkLoc(f)->file.status == 0))
  930.          fail;
  931.  
  932.  
  933.       pos = ftell(fd) + 1;
  934. #ifdef StandardLib
  935.       if (pos == 0)
  936.          fail;  /* may only be effective on ANSI systems */
  937. #endif                    /* StandardLib */
  938.  
  939.       return C_integer pos;
  940.       }
  941. end
  942.  
  943. /*
  944.  * stop(), write(), and writes() differ in whether they stop the program
  945.  *  and whether they output newlines. The macro GenWrite is used to
  946.  *  produce all three functions.
  947.  */
  948. #define False 0
  949. #define True 1
  950.  
  951. #begdef DefaultFile(error_out)
  952.    inline {
  953. #if error_out 
  954.       if ((k_errout.status & Fs_Write) == 0) 
  955.          runerr(213);
  956.       else {
  957.          f = k_errout.fd;
  958.          }
  959. #else                    /* error_out */
  960.       if ((k_output.status & Fs_Write) == 0) 
  961.          runerr(213);
  962.       else {
  963.          f = k_output.fd;
  964.          }
  965. #endif                    /* error_out */
  966.       }
  967. #enddef                    /* DefaultFile */
  968.  
  969. #begdef Finish(retvalue, nl, terminate)
  970. #if nl
  971.    /*
  972.     * Append a newline to the file and flush it.
  973.     */
  974. #ifdef RecordIO
  975.       if (status & Fs_Record)
  976.          flushrec(f);
  977.       else
  978. #endif                    /* RecordIO */
  979.          putc('\n', f);
  980.  
  981.       if (ferror(f)) 
  982.          runerr(214);
  983.       fflush(f);
  984.  
  985. #endif                    /* nl */
  986.  
  987. #if terminate
  988.             c_exit(ErrorExit);
  989. #else                    /* terminate */
  990.             return retvalue;
  991. #endif                    /* terminate */
  992. #enddef                    /* Finish */
  993.  
  994. #begdef GenWrite(name, nl, terminate)
  995.  
  996. #name "(a,b,...) - write arguments"
  997. #if !nl
  998.    " without newline terminator"
  999. #endif                    /* nl */
  1000. #if terminate
  1001.    " (starting on error output) and stop"
  1002. #endif                    /* terminate */
  1003. "."
  1004.  
  1005. #if terminate
  1006. function {} name(x[nargs])
  1007. #else                    /* terminate */
  1008. function {1} name(x[nargs])
  1009. #endif                    /* terminate */
  1010.  
  1011.    declare {
  1012.       FILE *f;
  1013.       word status =
  1014. #if terminate
  1015.         k_errout.status;
  1016. #else                    /* terminate */
  1017.         k_output.status;
  1018. #endif                    /* terminate */
  1019.  
  1020. #ifdef BadCode
  1021.       struct descrip temp;
  1022. #endif                    /* BadCode */
  1023.       }
  1024.  
  1025. #if terminate
  1026.    abstract {
  1027.       return empty_type
  1028.       }
  1029. #endif                    /* terminate */
  1030.  
  1031.    len_case nargs of {
  1032.       0: {
  1033. #if !terminate
  1034.          abstract {
  1035.             return null
  1036.             }
  1037. #endif                    /* terminate */
  1038.          DefaultFile(terminate)
  1039.          body {
  1040.             Finish(nulldesc, nl, terminate)
  1041.             }
  1042.          }
  1043.  
  1044.       default: {
  1045. #if !terminate
  1046.          abstract {
  1047.             return type(x) 
  1048.             }
  1049. #endif                    /* terminate */
  1050.          /*
  1051.           * See if we need to start with the default file.
  1052.           */
  1053.          if !is:file(x[0]) then
  1054.             DefaultFile(terminate)
  1055.  
  1056.          body {
  1057.             tended struct descrip t;
  1058.             register word n;
  1059.  
  1060.             /*
  1061.              * Loop through the arguments.
  1062.              */
  1063.             for (n = 0; n < nargs; n++) {
  1064.                if (is:file(x[n])) {    /* Current argument is a file */
  1065. #if nl
  1066.                   /*
  1067.                    * If this is not the first argument, output a newline to the
  1068.                    * current file and flush it.
  1069.                    */
  1070.                   if (n > 0) {
  1071.  
  1072.                      /*
  1073.                       * Append a newline to the file and flush it.
  1074.                       */
  1075. #ifdef RecordIO
  1076.                         if (status & Fs_Record)
  1077.                            flushrec(f);
  1078.                         else
  1079. #endif                    /* RecordIO */
  1080.  
  1081.                            putc('\n', f);
  1082.  
  1083.                         if (ferror(f)) 
  1084.                            runerr(214);
  1085.                         fflush(f);
  1086.                      }
  1087. #endif                    /* nl */
  1088.                   /*
  1089.                    * Switch the current file to the file named by the current
  1090.                    * argument providing it is a file.
  1091.                    */
  1092.           status = BlkLoc(x[n])->file.status;
  1093.                   if ((status & Fs_Write) == 0) 
  1094.                      runerr(213, x[n]);
  1095.                   f = BlkLoc(x[n])->file.fd;
  1096.                   }
  1097.                else {
  1098.                   /*
  1099.                    * Convert the argument to a string, defaulting to a empty
  1100.                    *  string.
  1101.                    */
  1102.                   if (!def:tmp_string(x[n],emptystr,t))
  1103.                      runerr(109, x[n]);
  1104.  
  1105.                   /*
  1106.                    * Output the string.
  1107.                    */
  1108. #ifdef RecordIO
  1109.                      if ((status & Fs_Record ? putrec(f, &t) :
  1110.                                              putstr(f, &t)) == Failed)
  1111. #else                    /* RecordIO */
  1112.                      if (putstr(f, &t) == Failed)
  1113. #endif                    /* RecordIO */
  1114.                         runerr(214, x[n]);
  1115.                   }
  1116.                }
  1117.  
  1118.             Finish(x[n-1], nl, terminate)
  1119.             }
  1120.          }
  1121.       }
  1122. end
  1123. #enddef                    /* GenWrite */
  1124.  
  1125. GenWrite(stop,   True,  True)  /* stop(s, ...) - write message and stop */
  1126. GenWrite(write,  True,  False) /* write(s, ...) - write with new-line */
  1127. GenWrite(writes, False, False) /* writes(s, ...) - write with no new-line */
  1128.  
  1129. #ifdef KeyboardFncs
  1130.  
  1131. "getch() - return a character from console."
  1132.  
  1133. function{0,1} getch()
  1134.    abstract {
  1135.       return string;
  1136.       }
  1137.    body {
  1138.       int i;
  1139.  
  1140.       i = getch();
  1141.       if (i<0 || i>255)
  1142.          fail;
  1143.       return string(1, &allchars[FromAscii(i) & 0xFF]);
  1144.       }
  1145. end
  1146.  
  1147. "getche() -- return a character from console with echo."
  1148.  
  1149. function{0,1} getche()
  1150.    abstract {
  1151.       return string;
  1152.       }
  1153.    body {
  1154.       int i;
  1155.  
  1156.       i = getche();
  1157.       if (i<0 || i>255)
  1158.          fail;
  1159.       return string(1, &allchars[FromAscii(i) & 0xFF]);
  1160.       }
  1161. end
  1162.  
  1163.  
  1164. "kbhit() -- Check to see if there is a keyboard character waiting to be read."
  1165.  
  1166. function{0,1} kbhit()
  1167.    abstract {
  1168.       return null
  1169.       }
  1170.    inline {
  1171.       if (kbhit()) {
  1172.          return nulldesc;
  1173.          }
  1174.       else fail;
  1175.       }
  1176. end
  1177. #endif                    /* KeyboardFncs */
  1178.  
  1179. "chdir(s) - change working directory to s."
  1180. function{0,1} chdir(s)
  1181.  
  1182.    if !cnv:C_string(s) then
  1183.       runerr(103,s)
  1184.    abstract {
  1185.       return null
  1186.       }
  1187.    inline {
  1188.  
  1189. /*
  1190.  * The following code is operating-system dependent [@fsys.01].
  1191.  *  Change directory.
  1192.  */
  1193.  
  1194. #if PORT
  1195. Deliberate Syntax Error
  1196. #endif                                  /* PORT */
  1197.  
  1198. #if AMIGA || ARM || MACINTOSH || MVS || VM
  1199.       runerr(121);
  1200. #endif                                  /* AMIGA || ARM || MACINTOSH ... */
  1201.  
  1202. #if ATARI_ST || MSDOS || OS2 || UNIX || VMS
  1203. #if MWC
  1204.       runerr(121);
  1205. #else                                   /* MWC */
  1206.       if (chdir(s) != 0)
  1207.          fail;
  1208.       return nulldesc;
  1209. #endif                                  /* MWC */
  1210. #endif                                  /* ATARI_ST || MSDOS || ... */
  1211.  
  1212. /*
  1213.  * End of operating-system specific code.
  1214.  */
  1215.    }
  1216. end
  1217.  
  1218. #if UNIX
  1219. "delay(i) - delay for i milliseconds."
  1220.  
  1221. function{1} delay(n)
  1222.  
  1223.    if !cnv:C_integer(n) then
  1224.       runerr(101,n)
  1225.    abstract {
  1226.       return null
  1227.       }
  1228.  
  1229.    inline {
  1230.  
  1231. /*
  1232.  * The following code is operating-system dependent [@fsys.01].  Delay for n
  1233.  *  milliseconds.
  1234.  */
  1235.  
  1236. #ifdef FD_SET
  1237. #define FD_NULL ((fd_set *) 0)
  1238. #else                    /* FD_SET */
  1239. #define FD_NULL ((long *) 0)
  1240. #endif                    /* FD_SET */
  1241.       struct timeval t;
  1242.       t.tv_sec = n / 1000;
  1243.       t.tv_usec = (n % 1000) * 1000;
  1244.       select(1, FD_NULL, FD_NULL, FD_NULL, &t);
  1245.  
  1246.  
  1247.       return nulldesc;
  1248.  
  1249.       }
  1250. end
  1251. #endif                    /* UNIX */
  1252.  
  1253. "flush(f) - flush file f."
  1254.  
  1255. function{1} flush(f)
  1256.    if !is:file(f) then
  1257.       runerr(105, f)
  1258.    abstract {
  1259.       return type(f)
  1260.       }
  1261.  
  1262.    body {
  1263.       FILE *fp;
  1264.  
  1265.  
  1266.       fp = BlkLoc(f)->file.fd;
  1267.       fflush(fp);
  1268.  
  1269.       /*
  1270.        * Return the flushed file.
  1271.        */
  1272.       return f;
  1273.       }
  1274. end
  1275.